home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d18
/
gsdb21.arc
/
GS_STRNG.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-01-04
|
11KB
|
290 lines
unit GS_Strng;
interface
uses
Crt, Dos;
function AllCaps(var t : string) : string;
procedure CnvAscToStr(var asc, st; lth : integer);
procedure CnvStrToAsc(var st, asc; lth : integer);
function StrDate(data : string) : string;
function StrNumber(num : real; lth,dec : integer) : string;
function StrLogic(tf : boolean) : string;
function SubStr(s : string; b,l : integer) : string;
function TrimL(strn : string):string; {Deletes leading spaces}
function TrimR(strn : string):string; {Deletes trailing spaces}
function Unique_Field : string; {Used to create a unique 8-byte string}
function ValNumber(strn : string) : real;
function ValLogic(strn : string) : boolean;
implementation
function AllCaps(var t : string) : string;
var
i : integer;
s : string;
begin
s := t;
for i := 1 to length(s) do s[i] := upcase(s[i]);
AllCaps := s;
end;
procedure CnvAscToStr(var asc, st; lth : integer);
var
a : array[0..255] of byte absolute asc;
s : string[255] absolute st;
i : integer;
begin
move(a,s[1],lth);
s[0] := chr(lth);
i := pos(#0,s);
if i > 0 then dec(i);
s[0] := chr(i);
end;
procedure CnvStrToAsc(var st, asc; lth : integer);
var
a : array[0..255] of byte absolute asc;
s : string[255] absolute st;
t : string;
i : integer;
begin
t := s;
FillChar(a,lth,#0);
i := length(t);
if i >= lth then i := lth;
move(t[1],a,i);
end;
function StrDate(data : string) : string;
var
t : string[10];
begin
t := ' ';
if length(data) = 8 then
begin
move(data[5], t[1], 2); {Move month to first two positions}
move(data[7], t[4], 2); {Move day to positions 4-5}
move(data[3], t[7], 2); {Move year to positions 7-8}
end;
t[3] := '/';
t[6] := '/'; {Insert delimiters}
t[0] := #8; {Set length to 8}
StrDate := t;
end;
function StrNumber(num : real; lth,dec : integer) : string;
var
s : string;
begin
Str(num:lth:dec,s);
StrNumber := s;
end;
function StrLogic(tf : boolean) : string;
begin
if tf then StrLogic := 'T' else StrLogic := 'F';
end;
{.pa}
{
SUBSTR
╔══════════════════════════════════════════════════════════════════╗
║ ║
║ The SUBSTR function extracts a substring from a string. ║
║ ║
║ Calling the Method: ║
║ ║
║ x := SubStr(s,b,l) ║
║ ║
║ ( where x is the string to be trimmed. ║
║ s is of type string. ║
║ b is the integer start of substring. ║
║ l is the integer length of substring. ║
║ ║
║ ║
║ Result: ║
║ ║
║ A substring of l positions beginning at b is returned. ║
║ ║
╚══════════════════════════════════════════════════════════════════╝
}
Function SubStr(s : string; b,l : integer) : string;
var
st : string;
i : integer;
begin
st := '';
if b < 0 then b := 1;
st := copy(s, b, l);
SubStr := st;
end;
{.pa}
{
TRIML
╔══════════════════════════════════════════════════════════════════╗
║ ║
║ The TRIML function removes leading spaces from a field. ║
║ ║
║ Calling the Method: ║
║ ║
║ d := TrimL(x) ║
║ ║
║ ( where x is the string to be trimmed. ║
║ d is of type string. ║
║ ║
║ Result: ║
║ ║
║ Leading spaces are removed and the field returned. ║
║ ║
╚══════════════════════════════════════════════════════════════════╝
}
function TrimL(strn : string) : string;
var
st : string;
begin
st := strn; {Load work string}
while (length(st) > 0) and (st[1] = ' ') do delete(st, 1, 1);
{Loop to delete leading spaces}
TrimL := st; {Return trimmed string}
end;
{.pa}
{
TRIMR
╔══════════════════════════════════════════════════════════════════╗
║ ║
║ The TRIMR function removes trailing spaces from a field. ║
║ ║
║ Calling the Method: ║
║ ║
║ d := TrimR(x) ║
║ ║
║ ( where x is the string to be trimmed. ║
║ d is of type string. ║
║ ║
║ Result: ║
║ ║
║ Trailing spaces are removed and the field returned. ║
║ ║
╚══════════════════════════════════════════════════════════════════╝
}
function TrimR(strn : string) : string;
var
l : integer;
st : string;
begin
st := strn; {Load work string}
l := length(st); {Load string length}
st[0] := '*'; {Ensure string length is not decimal 32,}
{which is an ASCII space}
while st[l] = ' ' do dec(l); {Loop searching down to first non-blank}
st[0] := chr(l); {Set string to new length}
TrimR := st; {Return trimmed length}
end;
{.pa}
{
UNIQUE_FIELD
╔══════════════════════════════════════════════════════════════════╗
║ ║
║ The UNIQUE-FIELD function creates an eight-character unique ║
║ value which may be used as a unique field for a database ║
║ record. The value is based on the data and time of the ║
║ function call, and is down to hundredths of a second. Thus, ║
║ each value returned will be unique. ║
║ ║
║ Calling the Method: ║
║ ║
║ d := Unique_Field ║
║ ║
║ ( where d is a string of length 8. ║
║ ║
║ Result: ║
║ ║
║ An 8-byte unique string of characters is returned. ║
║ ║
╚══════════════════════════════════════════════════════════════════╝
}
function Unique_Field : string;
var
y, mo, d, dow : Word;
h, mn, s, hund : Word;
LS,
LM : string;
{
┌─────────────────────────────────────┐
│ Convert a number to a character. │
│ Uses the ASCII characters starting │
│ at ASCII 64 │
└─────────────────────────────────────┘
}
function LZ(w : Word) : String;
begin
LZ := chr(w+64);
end;
{
┌──────────────────────────────────────┐
│ Beginning of Unique_Field function │
└──────────────────────────────────────┘
}
begin
GetDate(y,mo,d,dow); {Call TP 5.5 procedure for current date}
LS := LZ(y mod 10)+LZ(mo)+LZ(d); {Convert last digit of year, month, and}
{day to three individual ASCII characters}
{and concatenate}
GetTime(h,mn,s,hund); {Call TP 5.5 procedure for current time}
LS := LS+LZ(h)+LZ(mn)+LZ(s)+LZ(hund div 10)+LZ(hund mod 10);
{Convert hour, minute, second, and the}
{tens and units digits of the hundredths}
{of seconds to individual ASCII digits}
{and concatenate with the date string}
delay(100); {Delay to ensure next call will retrieve}
{an unique time stamp}
Unique_Field := LS; {Return the unique field}
end;
function ValNumber(strn : string) : real;
var
r : integer;
n : real;
begin
val(strn,n,r);
if r <> 0 then ValNumber := 0
else ValNumber := n;
end;
function ValLogic(strn : string) : boolean;
var
c : char;
begin
if strn[0] <> #1 then ValLogic := false
else
begin
c := strn[1];
if c in ['T','t','Y','y'] then ValLogic := true
else ValLogic := false;
end;
end;
end.